ADA Programming Guide/ADA Programming Guide.iso/ada_pcdp/adas/state.pas

Pascal/Delphi Source File | 1996-01-30 | 20KB | 638 lines

unit state;

  { Compile statements:
      control structures and tasking statements }

interface
uses global, util, expr;
procedure statement(var dx: integer; level: integer);

implementation

procedure statement(var dx: integer; level: integer);
var i: integer;
    lcx: integer;  { dummy variable to receive var parameter }

  procedure compoundstatement;
    { In Ada, there is no such thing as a compound statement.
        This just compiles a sequence of statements }
  begin
    insymbol;
    statement(dx, level);
    while sy in statbegsys do
      statement(dx, level);
    if sy = endsy then insymbol else error(erkey)
  end;

  procedure ifstatement;
    {
      if expression then statement 1; else statement 2;  compiles to:
            lc0: expression
            lc1: if false jump to lc2
                 statement 1
                 jump to lc3
            lc2: statement 2
            lc3:   (next statement)

      Since the jumps to lc2 and lc3 are emitted before the
      values of the location counters are know, their addresses
      must be remembered and fixed up afterwards. When an address
      is fixed up the "assembly" listing is annotated (but the
      listing itself is not fixed up).

      In Ada, the elsif construction causes a compilcation in
      that an unknown number of jumps must be fixed up.
      They are chained backwards and fixed up in a final loop.
         The following shows an example with a single elsif
         BEFORE the final jumps are fixed up:
             10: expression 1
             12: if false jump to 18
             13: statement 1
             17: jump to 0   -- end of chain
             18: expression 2
             23: if false jump to 27
             24: statement 2
             26: jump to 17  -- chain back to previous jump
             27: statement 3
             30:    (next statement)
         Now lc2 will contain 26 which can be fixed to
         jump to 30 and which contains the chain to 17 which
         also needs to be fixed to jump to 30
    }
  var x: item;
      lc1, lc2, lc3: integer;
  begin
    lc3 := 0;
    repeat
      insymbol;
      expression(level, x);
      if not (x.typ in [bools, notyp]) then error(ertyp);
      lc1 := lc;
      emit(11);
      if sy = thensy then
        begin
        insymbol;
        statement(dx, level);
        while sy in statbegsys do
          statement(dx, level);
        if not (sy in [endsy, elsesy, elsif]) then error(erkey)
        end
      else error(erkey);
      lc2 := lc;
      emit1(10, lc3);
      lc3 := lc2;
      code[lc1].y := lc;
      if listing then writeln(list, lc1:10, '   jump to here');
    until sy <> elsif;
    if sy = elsesy then
      compoundstatement
    else insymbol;
    repeat
      lc3 := code[lc2].y;
      code[lc2].y := lc;
      if listing then writeln(list, lc2:10, '   jump to here');
      lc2 := lc3
    until lc3 = 0;
    if sy = ifsy then insymbol else error(erpun)
  end;

  procedure loopstatement;
    { Compiles infinite loops as well as loops with exit statements }
  var x: item;
      lc1, lc2: integer;
  begin
    lc2 := 0;
    lc1 := lc;
    insymbol;
    while sy in statbegsys do
      if sy = exitsy then
        begin
        insymbol;
        if sy = when then insymbol else error(erkey);
        expression(level, x);
        if not (x.typ in [bools, notyp]) then error(ertyp);
        emit(35);
        lc2 := lc;
        emit(11);
        if sy = semicolon then insymbol else error(erpun)
        end
      else statement(dx, level);
    if sy = endsy then
      begin
      insymbol;
      if sy = loopsy then insymbol else error(erkey);
      emit1(10, lc1);
      if lc2 <> 0 then
        begin
        code[lc2].y := lc;
        if listing then writeln(list, lc2:10, '   jump to here');
        end
      end
  end;

  procedure whilestatement;
    { Compiles while statements (exit is not allowed) }
  var x: item;
      lc1, lc2: integer;
  begin
    insymbol;
    lc1 := lc;
    expression(level, x);
    if not (x.typ in [bools, notyp]) then error(ertyp);
    lc2 := lc;
    emit(11);
    if sy <> loopsy then error(erkey);
    compoundstatement;
    emit1(10, lc1);
    code[lc2].y := lc;
    if listing then writeln(list, lc2:10, '   jump to here');
    if sy = loopsy then insymbol else error(erpun)
  end;

  procedure forstatement;
    { Compiles for statements (exit is not allowed).
        In Ada, the loop control variable is implicitly
        declared in a new scope. Here the variable is entered in
        the same scope which means that it if it has the same
        name as a visible local variable, that variable will
        be used contrary to Ada semantics.
        If the variable name does not exist, it will be
        declared as type integer. }
  var cvt: types;
      x: item;
      i, lc1, lc2: integer;
  begin
    insymbol;
    if sy = ident then
      begin
      i := loc(level, id);
      if i <> 0 then insymbol
        else begin
        enter(id, variable, level);
        insymbol;
        i := t;
        with tab[i] do
          begin
          typ := ints;
          normal := true;
          adr := dx;
          dx := dx + 1
          end
        end;
      if tab[i].obj = variable then
        begin
        cvt := tab[i].typ;
        if not tab[i].normal then error(ertyp)
        else emit2(0, tab[i].lev, tab[i].adr);
        if not (cvt in [notyp, ints, bools, chars]) then error(ertyp)
        end
      else error(ertyp)
      end
    else error(erid);
    if sy = insy then
      begin
      insymbol;
      expression(level, x);
      if x.typ <> cvt then error(ertyp)
      end
    else error(erpun);
    if sy = colon then
      begin
      insymbol;
      expression(level, x);
      if x.typ <> cvt then error(ertyp)
      end
    else error(erkey);
    lc1 := lc;
    emit(14);
    if sy <> loopsy then error(erkey);
    lc2 := lc;
    compoundstatement;
    if sy = loopsy then insymbol else error(erkey);
    emit1(15, lc2);
    code[lc1].y := lc;
    if listing then writeln(list, lc1:10, '   jump to here');
  end;

  procedure standproc(n: integer);
    { Compiles standard procedures:
        get (read), skip_line (readln), put (write),
        put_line and new_line (writeln), and
        semaphore operations wait and signal. }
  var i, f: integer;
      x, y: item;
  begin
    case n of
      1,2:
       begin (* read *)
       if sy = lparent then
         begin
           insymbol;
           if sy <> ident then error(erid);
           i := loc(level, id);
           if i = 0 then error(ernf);
           insymbol;
           if tab[i].obj <> variable then error(ertyp);
           x.typ := tab[i].typ;
           x.ref := tab[i].ref;
           if tab[i].normal then f := 0 else f := 1;
           emit2(f, tab[i].lev, tab[i].adr);
           if sy = lparent then
             selector
             (level, x);
           if x.typ in [ints, chars, notyp] then emit1(27, ord(x.typ))
             else error(ertyp);
           if sy = rparent then insymbol else error(erpun)
         end;
         if n = 2 then emit(62)
       end;

    3,4: (* write *)
       begin
       if sy = lparent then
         begin
           insymbol;
           if sy = strng then
             begin
             emit1(24, sleng);
             emit1(28, inum);
             insymbol
             end
           else begin
             expression(level, x);
             if not (x.typ in stantyps) then error(ertyp);
             emit1(29, ord(x.typ))
             end;
         if sy = rparent then insymbol else error(erpun)
         end;
         if n = 4 then emit(63)
       end;

    5,6: (* wait, signal *)
       begin
         if sy <> lparent then error(erpun);
         insymbol;
         if sy <> ident then error(erid);
         i := loc(level, id);
         if i = 0 then error(ernf);
         insymbol;
         if tab[i].obj <> variable then error(ertyp);
         x.typ := tab[i].typ;
         x.ref := tab[i].ref;
         if tab[i].normal then f := 0 else f := 1;
         emit2(f, tab[i].lev, tab[i].adr);
         if sy = lparent then selector(level, x);
         if x.typ = ints then emit(n+1) else error(ertyp);
         if sy = rparent then insymbol else error(erpun)
       end
    end (* case *)
  end;

  procedure acceptstatement(var lcaccept: integer);
    { accept E(I: in Integer; J: out Integer) do
        S;
      end E;    is compiled to:
         lcaccept:  75  E
                    76  I (level and address)
                    S
                    79  J (level and address)
                    80  E
     }

  var e: integer;   { index in entry table }
      id1: alfa;    { save id to match with end }

      procedure skipacceptparms;
        { skip accept parameter declaration, if entry already seen }
      begin
        insymbol;
        if sy = lparent then
          begin
          repeat insymbol until sy = rparent;
          insymbol
          end
      end;

      procedure acceptparms;
        { accept statements may have zero, one or two parameters }

        procedure enterparm(var p: parmmode; var l: integer);
          { accept parameters are implicitly declared in the
            same block as the task (rather than declaring a
            new scope). They should be of standard types
            (integer, etc.) and can be of mode in or out
            so that copy semantics can be used.
            The procedure returns the mode of the parameter
            and the symbol table index l of the variable.
          }
        var x: integer;
            i: integer;
        begin
          insymbol;
          if sy <> ident then error(erid);
          i := loc(level, id);
          if i = 0 then  { if non-existent, create a new variable }
            begin
            enter(id, variable, level);
            i := t
            end;
          l := i;
          p := inparm;
          insymbol;
          if sy <> colon then error(erpun);
          insymbol;
          if sy = outsy then begin p := outparm; insymbol end
          else if sy = insy then insymbol;
          if sy <> ident then error(ertyp);
          x := loc(level, id);
          if x = 0 then error(ertyp);
          if tab[x].obj <> type1 then error(ertyp);
          with tab[i] do
            begin
            typ := tab[x].typ;
            ref := tab[x].ref;
            lev := level;
            normal := true;
            adr := dx;
            dx := dx + tab[x].adr
            end;
          insymbol
        end;

      begin
        { p1mode and p2mode store the modes and p1loc and p2loc
          store the symbol table indices of the parameters.
          This is important for out parameters which must have
          the copy back compiled AFTER compiling the accept body. }
        with entry[e] do       { assume initially no parameters }
          begin
          p1mode := noparm;
          p2mode := noparm;
          insymbol;
          if sy = lparent then
            begin
            enterparm(p1mode, p1loc);   { first parameter }
            if sy = rparent then insymbol
            else if sy = semicolon then
              begin
              enterparm(p2mode, p2loc); { second parameter }
              if sy <> rparent then error(erpun);
              insymbol
              end
            end
          end
        end;

        procedure emitaccept1;
        begin
          lcaccept := lc;   { return the address of the accept
                              which is used in the select statement }
          emit1(75, e);     { start accept of entry e }
          with entry[e] do
            begin           { copy in parms, if any }
            if p1mode = inparm then
              emit2(76, tab[p1loc].lev, tab[p1loc].adr);
            if p2mode = inparm then
              emit2(77, tab[p2loc].lev, tab[p2loc].adr)
            end
        end;

        procedure emitaccept2;
        begin
          with entry[e] do
            begin         { copy out parms, if any }
            if p1mode = outparm then
              emit2(78, tab[p1loc].lev, tab[p1loc].adr);
            if p2mode = outparm then
              emit2(79, tab[p2loc].lev, tab[p2loc].adr)
            end;
          emit1(80, e)    { complete accept of this entry }
        end;

  begin
      { The occurence of an entry name in an accept statement
        defines that entry (i.e. we ignore the task specification).
        Since there may be more than one accept for a given
        entry, check if this entry has been previously defined.}
    insymbol;
    if sy <> ident then error(erid);
    entry[0].taskid := curtask;  { sentinel for search }
    entry[0].name := id;
    id1 := id;     { save id to match end of accept }
    e := entries;
    while (entry[e].taskid <> curtask) or          { match task }
          (entry[e].name   <> id) do e := e - 1;   { and entry name }
    if e = 0 then   { new entry so allocate room in the entry table }
      begin
      entries := entries + 1;
      e := entries;
      if entries > emax then fatal(7);
      with entry[entries] do
        begin
        taskid := curtask;
        name := id;
        open := 0;
        waiting := 0;
        acceptparms     { compile entry parameter declaration }
        end
      end
    else skipacceptparms; { entry exists, so skip parameter declaration }
    if sy <> semicolon then  { check for degenerate body }
      begin
      if sy <> dosy then error(erkey);
      emitaccept1;         { instructions to commence accept }
      compoundstatement;   { sequence of statements in body }
      emitaccept2;         { instructions to complete accept }
      if sy = ident then
        begin
        if id <> id1 then error(erid);
        insymbol
        end
      end
  end;

  procedure selectstatement;
    { A select statement is compiled into a busy loop
      that checks for rendezvous and depends on the time slicing
      in the scheduler. After twice around the loop, the
      process is suspended. This allows a random implementation
      of the selection (see the interpreter).
      Only two branches with a terminate alternative are allowed.

         select
           when expr1 => accept E1 ...
         or
           when expr2 => accept E2 ...
         end select;    is compiled to:

              81 - start select
         lc0: expr1
         lc1: jump to lca if false
         lc5: accept E1 else jump to lca
         lc2: jump to lcc
         lca: expr2
         lc3: jump to lcb if false
         lc6: accept E2 else jump to lcb
         lc4: jump to lcc
         lcb: 82 - check terminate else skip next instruction
              32 - end procedure (task)
              83 - check if time to suspend
         lcc: jump to lc0
    }

  var lc0, lc1, lc2, lc3, lc4, lc5, lc6: integer;
      x: item;
  begin
    insymbol;
    emit(81);
    lc0 := lc;
    if sy <> when then emit1(24,1)
      else begin
      insymbol;
      expression(level, x);
      if not (x.typ in [bools, notyp]) then error(ertyp);
      if sy <> arrow then error(erkey);
      insymbol
      end;
    lc1 := lc;
    emit(11);
    acceptstatement(lc5);
    if sy = semicolon then insymbol else error(erpun);
    while sy in statbegsys do statement(dx, level);
    lc2 := lc;
    emit(10);
    code[lc1].y := lc;
    code[lc5].x := lc;
    if listing then writeln(list, lc1:10, '   jump to here');
    if listing then writeln(list, lc5:10, '   jump to here');
    if sy = orsy then
      begin
      insymbol;
      if sy <> when then emit1(24,1)  { if no guard, load true }
        else begin
        insymbol;
        expression(level, x);
        if not (x.typ in [bools, notyp]) then error(ertyp);
        if sy <> arrow then error(erkey);
        insymbol
        end;
      lc3 := lc;
      emit(11);
      acceptstatement(lc6);
      if sy = semicolon then insymbol else error(erpun);
      while sy in statbegsys do statement(dx, level);
      lc4 := lc;
      emit(10);
      code[lc3].y := lc;
      code[lc6].x := lc;
      if listing then writeln(list, lc3:10, '   jump to here');
      if listing then writeln(list, lc6:10, '   jump to here');
      end;
    if sy = orsy then
      begin
      insymbol;
      if sy <> terminate then error(erkey) else insymbol;
      if sy <> semicolon then error(erkey) else insymbol;
      emit(82);
      emit(32)
      end;
    emit(83);
    emit1(10,lc0);
    code[lc2].y := lc;
    code[lc4].y := lc;
    if listing then writeln(list, lc2:10, '   jump to here');
    if listing then writeln(list, lc4:10, '   jump to here');
    if sy = endsy then insymbol else error(erkey);
    if sy = selectsy then insymbol else error(erkey);
  end;

  procedure entrycall(x: integer);
    { Compile entry call.
         Must be compiled AFTER task BODY containing the accept.
           T.E(expr1, var2) will be compiled to:
              expr1
              70
              73  I (level and address)
              74
    }
  var e: integer;
      i: integer;
      j: item;
  begin
    if sy <> period then error(erpun);
    insymbol;
    if sy <> ident then error(erid);
    entry[0].taskid := x;   { Search for match in entry table }
    entry[0].name := id;
    e := entries;
    while (entry[e].taskid <> x) or
          (entry[e].name <> id) do e := e - 1;
    if e = 0 then error(erid);
    insymbol;
    with entry[e] do
      if p1mode <> noparm then
        begin
        if sy <> lparent then error(erpun);
        insymbol;
        if p1mode = inparm then  { First parameter is in mode }
          begin                  { so compile expression }
          expression(level, j);
          emit(70)
          end
        else
          begin                  { First parameter is out mode }
          i := loc(level, id);   {  so emit instruction with address }
          emit2(72, tab[i].lev, tab[i].adr);
          insymbol
          end;
        if p2mode <> noparm then { Similarly, for second parameter }
          begin
          if sy <> comma then error(erpun);
          insymbol;
          if p2mode = inparm then
            begin
            expression(level, j);
            emit(71)
            end
          else
            begin
            i := loc(level, id);
            emit2(73, tab[i].lev, tab[i].adr);
            insymbol
            end
          end;
        if sy = rparent then insymbol else error(erpun)
        end;
    emit1(74, e)     { Call entry }
  end;

  begin (* statement *)
    if sy in statbegsys then
      case sy of
        ident:   { assignment or procedure calls }
          begin
          i := loc(level, id);
          insymbol;
          if i = 0 then error(ernf);
          if tab[i].obj = variable then
             assignment(level, i, tab[i].lev, tab[i].adr)
          else if tab[i].obj = prozedure then
             if tab[i].lev <> 0 then call(level, i)
             else standproc(tab[i].adr)
          else if tab[i].obj = task then
            entrycall(i)
          else error(ertyp)
          end;

        acceptsy: acceptstatement(lcx);
        ifsy:     ifstatement;
        whilesy:  whilestatement;
        loopsy:   loopstatement;
        forsy:    forstatement;
        selectsy: selectstatement;
        nullsy:   insymbol;
      end (* case *);
    if sy = semicolon then insymbol else error(erpun);
  end;

end.